home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / sparc / vm.lisp < prev   
Encoding:
Text File  |  1992-02-25  |  9.0 KB  |  335 lines
  1. ;;; -*- Package: SPARC -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: vm.lisp,v 1.5 92/02/25 07:13:47 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; This file contains the VM definition for the SPARC.
  15. ;;;
  16. ;;; Written by William Lott.
  17. ;;;
  18. (in-package "SPARC")
  19.  
  20.  
  21. ;;;; Define the registers
  22.  
  23. (eval-when (compile eval)
  24.  
  25. (defmacro defreg (name offset)
  26.   (let ((offset-sym (symbolicate name "-OFFSET")))
  27.     `(eval-when (compile eval load)
  28.        (defconstant ,offset-sym ,offset)
  29.        (setf (svref *register-names* ,offset-sym) ,(symbol-name name)))))
  30.  
  31. (defmacro defregset (name &rest regs)
  32.   `(eval-when (compile eval load)
  33.      (defconstant ,name
  34.        (list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs)))))
  35.  
  36. ); eval-when (compile eval)
  37.  
  38.  
  39. (eval-when (compile load eval)
  40.  
  41. (defvar *register-names* (make-array 32 :initial-element nil))
  42.  
  43. ); eval-when (compile load eval)
  44.  
  45.  
  46. ;; Globals.  These are difficult to extract from a sigcontext.
  47. (defreg zero 0)
  48. (defreg alloc 1)
  49. (defreg null 2)
  50. (defreg csp 3)
  51. (defreg cfp 4)
  52. (defreg bsp 5)
  53. (defreg nfp 6)
  54. (defreg cfunc 7)
  55.  
  56. ;; Outs.  These get clobbered when we call into C.
  57. (defreg nl0 8)
  58. (defreg nl1 9)
  59. (defreg nl2 10)
  60. (defreg nl3 11)
  61. (defreg nl4 12)
  62. (defreg nl5 13)
  63. (defreg nsp 14)
  64. (defreg nargs 15)
  65.  
  66. ;; Locals.  These are preserved when we call into C.
  67. (defreg a0 16)
  68. (defreg a1 17)
  69. (defreg a2 18)
  70. (defreg a3 19)
  71. (defreg a4 20)
  72. (defreg a5 21)
  73. (defreg ocfp 22)
  74. (defreg lra 23)
  75.  
  76. ;; Ins.  These are preserved just like locals.
  77. (defreg cname 24)
  78. (defreg lexenv 25)
  79. (defreg l0 26)
  80. (defreg l1 27)
  81. (defreg l2 28)
  82. (defreg code 29)
  83. ;; we can't touch reg 30 if we ever want to return
  84. (defreg lip 31)
  85.  
  86. (defregset non-descriptor-regs
  87.   nl0 nl1 nl2 nl3 nl4 nl5 cfunc nargs nfp)
  88.  
  89. (defregset descriptor-regs
  90.   a0 a1 a2 a3 a4 a5 ocfp lra cname lexenv l0 l1 l2)
  91.  
  92. (defregset register-arg-offsets
  93.   a0 a1 a2 a3 a4 a5)
  94.  
  95.  
  96.  
  97. ;;;; SB and SC definition:
  98.  
  99. (define-storage-base registers :finite :size 32)
  100. (define-storage-base float-registers :finite :size 32)
  101. (define-storage-base control-stack :unbounded :size 8)
  102. (define-storage-base non-descriptor-stack :unbounded :size 0)
  103. (define-storage-base constant :non-packed)
  104. (define-storage-base immediate-constant :non-packed)
  105.  
  106. ;;;
  107. ;;; Handy macro so we don't have to keep changing all the numbers whenever
  108. ;;; we insert a new storage class.
  109. ;;; 
  110. (defmacro define-storage-classes (&rest classes)
  111.   (do ((forms (list 'progn)
  112.           (let* ((class (car classes))
  113.              (sc-name (car class))
  114.              (constant-name (intern (concatenate 'simple-string
  115.                              (string sc-name)
  116.                              "-SC-NUMBER"))))
  117.         (list* `(define-storage-class ,sc-name ,index
  118.               ,@(cdr class))
  119.                `(defconstant ,constant-name ,index)
  120.                `(export ',constant-name)
  121.                forms)))
  122.        (index 0 (1+ index))
  123.        (classes classes (cdr classes)))
  124.       ((null classes)
  125.        (nreverse forms))))
  126.  
  127. (define-storage-classes
  128.  
  129.   ;; Non-immediate contstants in the constant pool
  130.   (constant constant)
  131.  
  132.   ;; ZERO and NULL are in registers.
  133.   (zero immediate-constant)
  134.   (null immediate-constant)
  135.  
  136.   ;; Anything else that can be an immediate.
  137.   (immediate immediate-constant)
  138.  
  139.  
  140.   ;; **** The stacks.
  141.  
  142.   ;; The control stack.  (Scanned by GC)
  143.   (control-stack control-stack)
  144.  
  145.   ;; The non-descriptor stacks.
  146.   (signed-stack non-descriptor-stack) ; (signed-byte 32)
  147.   (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32)
  148.   (base-char-stack non-descriptor-stack) ; non-descriptor characters.
  149.   (sap-stack non-descriptor-stack) ; System area pointers.
  150.   (single-stack non-descriptor-stack) ; single-floats
  151.   (double-stack non-descriptor-stack
  152.         :element-size 2 :alignment 2) ; double floats.
  153.  
  154.  
  155.   ;; **** Things that can go in the integer registers.
  156.  
  157.   ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
  158.   ;; bad will happen if they are.  (fixnums, characters, header values, etc).
  159.   (any-reg
  160.    registers
  161.    :locations #.(append non-descriptor-regs descriptor-regs)
  162.    :constant-scs (zero immediate)
  163.    :save-p t
  164.    :alternate-scs (control-stack))
  165.  
  166.   ;; Pointer descriptor objects.  Must be seen by GC.
  167.   (descriptor-reg registers
  168.    :locations #.descriptor-regs
  169.    :constant-scs (constant null immediate)
  170.    :save-p t
  171.    :alternate-scs (control-stack))
  172.  
  173.   ;; Non-Descriptor characters
  174.   (base-char-reg registers
  175.    :locations #.non-descriptor-regs
  176.    :constant-scs (immediate)
  177.    :save-p t
  178.    :alternate-scs (base-char-stack))
  179.  
  180.   ;; Non-Descriptor SAP's (arbitrary pointers into address space)
  181.   (sap-reg registers
  182.    :locations #.non-descriptor-regs
  183.    :constant-scs (immediate)
  184.    :save-p t
  185.    :alternate-scs (sap-stack))
  186.  
  187.   ;; Non-Descriptor (signed or unsigned) numbers.
  188.   (signed-reg registers
  189.    :locations #.non-descriptor-regs
  190.    :constant-scs (zero immediate)
  191.    :save-p t
  192.    :alternate-scs (signed-stack))
  193.   (unsigned-reg registers
  194.    :locations #.non-descriptor-regs
  195.    :constant-scs (zero immediate)
  196.    :save-p t
  197.    :alternate-scs (unsigned-stack))
  198.  
  199.   ;; Random objects that must not be seen by GC.  Used only as temporaries.
  200.   (non-descriptor-reg registers
  201.    :locations #.non-descriptor-regs)
  202.  
  203.   ;; Pointers to the interior of objects.  Used only as an temporary.
  204.   (interior-reg registers
  205.    :locations (#.lip-offset))
  206.  
  207.  
  208.   ;; **** Things that can go in the floating point registers.
  209.  
  210.   ;; Non-Descriptor single-floats.
  211.   (single-reg float-registers
  212.    :locations (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30)
  213.    ;; ### Note: We really should have every location listed, but then we
  214.    ;; would have to make load-tns work with element-sizes other than 1.
  215.    :constant-scs ()
  216.    :save-p t
  217.    :alternate-scs (single-stack))
  218.  
  219.   ;; Non-Descriptor double-floats.
  220.   (double-reg float-registers
  221.    :locations (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30)
  222.    ;; ### Note: load-tns don't work with an element-size other than 1.
  223.    ;; :element-size 2 :alignment 2
  224.    :constant-scs ()
  225.    :save-p t
  226.    :alternate-scs (double-stack))
  227.  
  228.  
  229.   ;; A catch or unwind block.
  230.   (catch-block control-stack :element-size vm:catch-block-size))
  231.  
  232.  
  233.  
  234. ;;;; Make some random tns for important registers.
  235.  
  236. (eval-when (compile eval)
  237.  
  238. (defmacro defregtn (name sc)
  239.   (let ((offset-sym (symbolicate name "-OFFSET"))
  240.     (tn-sym (symbolicate name "-TN")))
  241.     `(defparameter ,tn-sym
  242.        (make-random-tn :kind :normal
  243.                :sc (sc-or-lose ',sc)
  244.                :offset ,offset-sym))))
  245.  
  246. ); eval-when (compile eval)
  247.  
  248. (defregtn zero any-reg)
  249. (defregtn null descriptor-reg)
  250. (defregtn code descriptor-reg)
  251. (defregtn alloc any-reg)
  252.  
  253. (defregtn nargs any-reg)
  254. (defregtn bsp any-reg)
  255. (defregtn csp any-reg)
  256. (defregtn cfp any-reg)
  257. (defregtn ocfp any-reg)
  258. (defregtn nsp any-reg)
  259.  
  260.  
  261.  
  262. ;;; Immediate-Constant-SC  --  Interface
  263. ;;;
  264. ;;; If value can be represented as an immediate constant, then return the
  265. ;;; appropriate SC number, otherwise return NIL.
  266. ;;;
  267. (def-vm-support-routine immediate-constant-sc (value)
  268.   (typecase value
  269.     ((integer 0 0)
  270.      (sc-number-or-lose 'zero *backend*))
  271.     (null
  272.      (sc-number-or-lose 'null *backend*))
  273.     ((or fixnum system-area-pointer character)
  274.      (sc-number-or-lose 'immediate *backend*))
  275.     (symbol
  276.      (if (static-symbol-p value)
  277.      (sc-number-or-lose 'immediate *backend*)
  278.      nil))))
  279.  
  280.  
  281. ;;;; Function Call Parameters
  282.  
  283. ;;; The SC numbers for register and stack arguments/return values.
  284. ;;;
  285. (defconstant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg))
  286. (defconstant immediate-arg-scn (meta-sc-number-or-lose 'any-reg))
  287. (defconstant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack))
  288.  
  289. (eval-when (compile load eval)
  290.  
  291. ;;; Offsets of special stack frame locations
  292. (defconstant ocfp-save-offset 0)
  293. (defconstant lra-save-offset 1)
  294. (defconstant nfp-save-offset 2)
  295.  
  296. ;;; The number of arguments/return values passed in registers.
  297. ;;;
  298. (defconstant register-arg-count 6)
  299.  
  300. ;;; Names to use for the argument registers.
  301. ;;; 
  302. (defconstant register-arg-names '(a0 a1 a2 a3 a4 a5))
  303.  
  304. ); Eval-When (Compile Load Eval)
  305.  
  306.  
  307. ;;; A list of TN's describing the register arguments.
  308. ;;;
  309. (defparameter register-arg-tns
  310.   (mapcar #'(lambda (n)
  311.           (make-random-tn :kind :normal
  312.                   :sc (sc-or-lose 'descriptor-reg)
  313.                   :offset n))
  314.       register-arg-offsets))
  315.  
  316.  
  317.  
  318. ;;; LOCATION-PRINT-NAME  --  Interface
  319. ;;;
  320. ;;;    This function is called by debug output routines that want a pretty name
  321. ;;; for a TN's location.  It returns a thing that can be printed with PRINC.
  322. ;;;
  323. (def-vm-support-routine location-print-name (tn)
  324.   (declare (type tn tn))
  325.   (let ((sb (sb-name (sc-sb (tn-sc tn))))
  326.     (offset (tn-offset tn)))
  327.     (ecase sb
  328.       (registers (or (svref *register-names* offset)
  329.              (format nil "R~D" offset)))
  330.       (float-registers (format nil "F~D" offset))
  331.       (control-stack (format nil "CS~D" offset))
  332.       (non-descriptor-stack (format nil "NS~D" offset))
  333.       (constant (format nil "Const~D" offset))
  334.       (immediate-constant "Immed"))))
  335.